home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / recobj.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  55 lines
  1. ;;; "recobj.scm" Records implemented as objects.
  2. ;;;From: whumeniu@datap.ca (Wade Humeniuk)
  3.  
  4. (require 'object)
  5. (require 'common-list-functions)
  6.  
  7. (define record-type-name (make-generic-method))
  8. (define record-accessor (make-generic-method))
  9. (define record-modifier (make-generic-method))
  10. (define record? (make-generic-predicate))
  11. (define record-constructor (make-generic-method))
  12.  
  13. (define (make-record-type type-name field-names)
  14.   (define self (make-object))
  15.  
  16.   (make-method! self record-type-name
  17.         (lambda (self)
  18.           type-name))
  19.   (make-method! self record-accessor
  20.         (lambda (self field-name)
  21.           (let ((index (comlist:position field-name field-names)))
  22.             (if (not index)
  23.             (slib:error "record-accessor: invalid field-name argument."
  24.                     field-name))
  25.             (lambda (obj)
  26.               (record-accessor obj index)))))
  27.  
  28.   (make-method! self record-modifier
  29.         (lambda (self field-name)
  30.           (let ((index (comlist:position field-name field-names)))
  31.             (if (not index)
  32.             (slib:error "record-accessor: invalid field-name argument."
  33.                     field-name))
  34.             (lambda (obj newval)
  35.               (record-modifier obj index newval)))))
  36.   
  37.   (make-method! self record? (lambda (self) #t))
  38.  
  39.   (make-method! self record-constructor
  40.         (lambda (class . field-values)
  41.           (let ((values (apply vector field-values)))
  42.             (define self (make-object))
  43.             (make-method! self record-accessor
  44.                   (lambda (self index)
  45.                     (vector-ref values index)))
  46.             (make-method! self record-modifier
  47.                   (lambda (self index newval)
  48.                     (vector-set! values index newval)))
  49.             (make-method! self record-type-name
  50.                   (lambda (self) (record-type-name class)))
  51.             self)))
  52.   self)
  53.  
  54. (provide 'record-object)
  55. (provide 'record)